home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 2010 April / PCWorld0410.iso / hity wydania / Ubuntu 9.10 PL / karmelkowy-koliberek-desktop-9.10-i386-PL.iso / casper / filesystem.squashfs / usr / share / perl5 / Mail / Cap.pm < prev    next >
Text File  |  2008-07-29  |  6KB  |  242 lines
  1. # Copyrights 1995-2008 by Mark Overmeer <perl@overmeer.net>.
  2. #  For other contributors see ChangeLog.
  3. # See the manual pages for details on the licensing terms.
  4. # Pod stripped from pm file by OODoc 1.05.
  5. package Mail::Cap;
  6. use vars '$VERSION';
  7. $VERSION = '2.04';
  8.  
  9. use strict;
  10.  
  11. sub Version { our $VERSION }
  12.  
  13.  
  14. our $useCache = 1;  # don't evaluate tests every time
  15.  
  16. my @path;
  17. if($^O eq "MacOS")
  18. {   @path = split /\,/, $ENV{MAILCAPS} || "$ENV{HOME}mailcap";
  19. }
  20. else
  21. {   @path = split /\:/
  22.       , ( $ENV{MAILCAPS} || (defined $ENV{HOME} ? "$ENV{HOME}/.mailcap:" : '')
  23.         . '/etc/mailcap:/usr/etc/mailcap:/usr/local/etc/mailcap'
  24.         );   # this path is specified under RFC1524 appendix A 
  25. }
  26.  
  27.  
  28. sub new
  29. {   my $class = shift;
  30.     
  31.     unshift @_, 'filename' if @_ % 2;
  32.     my %args  = @_;
  33.  
  34.     my $take_all = $args{take} && uc $args{take} eq 'ALL';
  35.  
  36.     my $self  = bless {_count => 0}, $class;
  37.  
  38.     $self->_process_file($args{filename})
  39.         if defined $args{filename} && -r $args{filename};
  40.  
  41.     if(!defined $args{filename} || $take_all)
  42.     {   foreach my $fname (@path)
  43.         {   -r $fname or next;
  44.  
  45.             $self->_process_file($fname);
  46.             last unless $take_all;
  47.         }
  48.     }
  49.  
  50.     unless($self->{_count})
  51.     {   # Set up default mailcap
  52.         $self->{'audio/*'} = [{'view' => "showaudio %s"}];
  53.         $self->{'image/*'} = [{'view' => "xv %s"}];
  54.         $self->{'message/rfc822'} = [{'view' => "xterm -e metamail %s"}];
  55.     }
  56.  
  57.     $self;
  58. }
  59.  
  60. sub _process_file
  61. {   my $self = shift;
  62.     my $file = shift or return;
  63.  
  64.     local *MAILCAP;
  65.     open MAILCAP, $file
  66.         or return;
  67.  
  68.     $self->{_file} = $file;
  69.  
  70.     local $_;
  71.     while(<MAILCAP>)
  72.     {   next if /^\s*#/; # comment
  73.         next if /^\s*$/; # blank line
  74.         $_ .= <MAILCAP> while s/\\\s*$//; # continuation line
  75.         chomp;
  76.         s/\0//g;            # ensure no NULs in the line
  77.         s/([^\\]);/$1\0/g;  # make field separator NUL
  78.  
  79.         my @parts = split /\s*\0\s*/, $_;
  80.         my $type  = shift @parts;
  81.         $type    .= "/*" if $type !~ m[/];
  82.  
  83.         my $view  = shift @parts;
  84.         $view     =~ s/\\;/;/g;
  85.         my %field = (view => $view);
  86.  
  87.         foreach (@parts)
  88.         {   my($key, $val) = split /\s*\=\s*/, $_, 2;
  89.             $val =~ s/\\;/;/g if defined $val;
  90.             $field{$key} = defined $val ? $val : 1;
  91.         }
  92.  
  93.         if(my $test = $field{test})
  94.         {   unless ($test =~ /\%/)
  95.             {   # No parameters in test, can perform it right away
  96.                 system $test;
  97.                 next if $?;
  98.             }
  99.         }
  100.  
  101.         # record this entry
  102.         unless(exists $self->{$type})
  103.         {   $self->{$type} = [];
  104.             $self->{_count}++; 
  105.         }
  106.         push @{$self->{$type}}, \%field;
  107.     }
  108.  
  109.     close MAILCAP;
  110. }
  111.  
  112.  
  113. sub view    { my $self = shift; $self->_run($self->viewCmd(@_))    }
  114. sub compose { my $self = shift; $self->_run($self->composeCmd(@_)) }
  115. sub edit    { my $self = shift; $self->_run($self->editCmd(@_))    }
  116. sub print   { my $self = shift; $self->_run($self->printCmd(@_))   }
  117.  
  118. sub _run($)
  119. {   my ($self, $cmd) = @_;
  120.     defined $cmd or return 0;
  121.  
  122.     system $cmd;
  123.     1;
  124. }
  125.  
  126.  
  127. sub viewCmd    { shift->_createCommand(view    => @_) }
  128. sub composeCmd { shift->_createCommand(compose => @_) }
  129. sub editCmd    { shift->_createCommand(edit    => @_) }
  130. sub printCmd   { shift->_createCommand(print   => @_) }
  131.  
  132. sub _createCommand($$$)
  133. {   my ($self, $method, $type, $file) = @_;
  134.     my $entry = $self->getEntry($type, $file);
  135.  
  136.     $entry && exists $entry->{$method}
  137.         or return undef;
  138.  
  139.     $self->expandPercentMacros($entry->{$method}, $type, $file);
  140. }
  141.  
  142. sub makeName($$)
  143. {   my ($self, $type, $basename) = @_;
  144.     my $template = $self->nametemplate($type)
  145.         or return $basename;
  146.  
  147.     $template =~ s/%s/$basename/g;
  148.     $template;
  149. }
  150.  
  151.  
  152. sub field($$)
  153. {   my($self, $type, $field) = @_;
  154.     my $entry = $self->getEntry($type);
  155.     $entry->{$field};
  156. }
  157.  
  158.  
  159. sub description     { shift->field(shift, 'description');     }
  160. sub textualnewlines { shift->field(shift, 'textualnewlines'); }
  161. sub x11_bitmap      { shift->field(shift, 'x11-bitmap');      }
  162. sub nametemplate    { shift->field(shift, 'nametemplate');    }
  163.  
  164. sub getEntry
  165. {   my($self, $origtype, $file) = @_;
  166.  
  167.     return $self->{_cache}{$origtype}
  168.         if $useCache && exists $self->{_cache}{$origtype};
  169.  
  170.     my ($fulltype, @params) = split /\s*;\s*/, $origtype;
  171.     my ($type, $subtype)    = split m[/], $fulltype, 2;
  172.     $subtype ||= '';
  173.  
  174.     my $entry;
  175.     foreach (@{$self->{"$type/$subtype"}}, @{$self->{"$type/*"}})
  176.     {   if(exists $_->{'test'})
  177.         {   # must run test to see if it applies
  178.             my $test = $self->expandPercentMacros($_->{'test'},
  179.                               $origtype, $file);
  180.             system $test;
  181.             next if $?;
  182.         }
  183.         $entry = { %$_ };  # make copy
  184.         last;
  185.     }
  186.     $self->{_cache}{$origtype} = $entry if $useCache;
  187.     $entry;
  188. }
  189.  
  190. sub expandPercentMacros
  191. {   my ($self, $text, $type, $file) = @_;
  192.     defined $type or return $text;
  193.     defined $file or $file = "";
  194.  
  195.     my ($fulltype, @params) = split /\s*;\s*/, $type;
  196.     ($type, my $subtype)    = split m[/], $fulltype, 2;
  197.  
  198.     my %params;
  199.     foreach (@params)
  200.     {   my($key, $val) = split /\s*=\s*/, $_, 2;
  201.         $params{$key} = $val;
  202.     }
  203.     $text =~ s/\\%/\0/g;        # hide all escaped %'s
  204.     $text =~ s/%t/$fulltype/g;  # expand %t
  205.     $text =~ s/%s/$file/g;      # expand %s
  206.     {   # expand %{field}
  207.         local $^W = 0;  # avoid warnings when expanding %params
  208.         $text =~ s/%\{\s*(.*?)\s*\}/$params{$1}/g;
  209.     }
  210.     $text =~ s/\0/%/g;
  211.     $text;
  212. }
  213.  
  214. # This following procedures can be useful for debugging purposes
  215.  
  216. sub dumpEntry
  217. {   my($hash, $prefix) = @_;
  218.     defined $prefix or $prefix = "";
  219.     print "$prefix$_ = $hash->{$_}\n"
  220.         for sort keys %$hash;
  221. }
  222.  
  223. sub dump
  224. {   my $self = shift;
  225.     foreach (keys %$self)
  226.     {   next if /^_/;
  227.         print "$_\n";
  228.         foreach (@{$self->{$_}})
  229.         {   dumpEntry($_, "\t");
  230.             print "\n";
  231.         }
  232.     }
  233.  
  234.     if(exists $self->{_cache})
  235.     {   print "Cached types\n";
  236.         print "\t$_\n"
  237.             for keys %{$self->{_cache}};
  238.     }
  239. }
  240.  
  241. 1;
  242.